data <- read.csv("./archive/accepted_2007_to_2018q4.csv/accepted_2007_to_2018Q4.csv")
head(data[1:5,1:10])
## id member_id loan_amnt funded_amnt funded_amnt_inv term int_rate
## 1 68407277 NA 3600 3600 3600 36 months 13.99
## 2 68355089 NA 24700 24700 24700 36 months 11.99
## 3 68341763 NA 20000 20000 20000 60 months 10.78
## 4 66310712 NA 35000 35000 35000 60 months 14.85
## 5 68476807 NA 10400 10400 10400 60 months 22.45
## installment grade sub_grade
## 1 123.03 C C4
## 2 820.28 C C1
## 3 432.66 B B4
## 4 829.90 C C5
## 5 289.91 F F1
summary(data[,1:10])
## id member_id loan_amnt funded_amnt
## Length:2260701 Mode:logical Min. : 500 Min. : 500
## Class :character NA's:2260701 1st Qu.: 8000 1st Qu.: 8000
## Mode :character Median :12900 Median :12875
## Mean :15047 Mean :15042
## 3rd Qu.:20000 3rd Qu.:20000
## Max. :40000 Max. :40000
## NA's :33 NA's :33
## funded_amnt_inv term int_rate installment
## Min. : 0 Length:2260701 Min. : 5.31 Min. : 4.93
## 1st Qu.: 8000 Class :character 1st Qu.: 9.49 1st Qu.: 251.65
## Median :12800 Mode :character Median :12.62 Median : 377.99
## Mean :15023 Mean :13.09 Mean : 445.81
## 3rd Qu.:20000 3rd Qu.:15.99 3rd Qu.: 593.32
## Max. :40000 Max. :30.99 Max. :1719.83
## NA's :33 NA's :33 NA's :33
## grade sub_grade
## Length:2260701 Length:2260701
## Class :character Class :character
## Mode :character Mode :character
##
##
##
##
dim(data)
## [1] 2260701 151
num_qualitative <- sum(sapply(data, function(x) is.factor(x) | is.character(x)))
num_quantitative <- sum(sapply(data, is.numeric))
cat("Número de variables cualitativas:", num_qualitative, "\n")
## Número de variables cualitativas: 38
cat("Número de variables cuantitativas:", num_quantitative, "\n")
## Número de variables cuantitativas: 112
cat("Número total de variables:", ncol(data), "\n")
## Número total de variables: 151
Lo que se vemos es que disponemos de un dataset de dimensiones bastante grandes, concretamente tenemos 2,260,701 muestras y 151 variables. De entre estas últimas, tenemos de 38 variables cualitativas y 112 cuantitativas, además de una variable lógica.
1.1. Exploración de los nombres de las columnas y revisión de datos faltantes.
missing_values <- colSums(is.na(data))
missing_percentage <- round((missing_values / nrow(data)) * 100, 2)
missing_data <- data.frame(
Missing_Count = missing_values,
Missing_Percent = missing_percentage
)
missing_data[missing_data$Missing_Count > 0, ]
## Missing_Count Missing_Percent
## member_id 2260701 100.00
## loan_amnt 33 0.00
## funded_amnt 33 0.00
## funded_amnt_inv 33 0.00
## int_rate 33 0.00
## installment 33 0.00
## annual_inc 37 0.00
## dti 1744 0.08
## delinq_2yrs 62 0.00
## fico_range_low 33 0.00
## fico_range_high 33 0.00
## inq_last_6mths 63 0.00
## mths_since_last_delinq 1158535 51.25
## mths_since_last_record 1901545 84.11
## open_acc 62 0.00
## pub_rec 62 0.00
## revol_bal 33 0.00
## revol_util 1835 0.08
## total_acc 62 0.00
## out_prncp 33 0.00
## out_prncp_inv 33 0.00
## total_pymnt 33 0.00
## total_pymnt_inv 33 0.00
## total_rec_prncp 33 0.00
## total_rec_int 33 0.00
## total_rec_late_fee 33 0.00
## recoveries 33 0.00
## collection_recovery_fee 33 0.00
## last_pymnt_amnt 33 0.00
## last_fico_range_high 33 0.00
## last_fico_range_low 33 0.00
## collections_12_mths_ex_med 178 0.01
## mths_since_last_major_derog 1679926 74.31
## policy_code 33 0.00
## annual_inc_joint 2139991 94.66
## dti_joint 2139995 94.66
## acc_now_delinq 62 0.00
## tot_coll_amt 70309 3.11
## tot_cur_bal 70309 3.11
## open_acc_6m 866163 38.31
## open_act_il 866162 38.31
## open_il_12m 866162 38.31
## open_il_24m 866162 38.31
## mths_since_rcnt_il 909957 40.25
## total_bal_il 866162 38.31
## il_util 1068883 47.28
## open_rv_12m 866162 38.31
## open_rv_24m 866162 38.31
## max_bal_bc 866162 38.31
## all_util 866381 38.32
## total_rev_hi_lim 70309 3.11
## inq_fi 866162 38.31
## total_cu_tl 866163 38.31
## inq_last_12m 866163 38.31
## acc_open_past_24mths 50063 2.21
## avg_cur_bal 70379 3.11
## bc_open_to_buy 74968 3.32
## bc_util 76104 3.37
## chargeoff_within_12_mths 178 0.01
## delinq_amnt 62 0.00
## mo_sin_old_il_acct 139104 6.15
## mo_sin_old_rev_tl_op 70310 3.11
## mo_sin_rcnt_rev_tl_op 70310 3.11
## mo_sin_rcnt_tl 70309 3.11
## mort_acc 50063 2.21
## mths_since_recent_bc 73445 3.25
## mths_since_recent_bc_dlq 1741000 77.01
## mths_since_recent_inq 295468 13.07
## mths_since_recent_revol_delinq 1520342 67.25
## num_accts_ever_120_pd 70309 3.11
## num_actv_bc_tl 70309 3.11
## num_actv_rev_tl 70309 3.11
## num_bc_sats 58623 2.59
## num_bc_tl 70309 3.11
## num_il_tl 70309 3.11
## num_op_rev_tl 70309 3.11
## num_rev_accts 70310 3.11
## num_rev_tl_bal_gt_0 70309 3.11
## num_sats 58623 2.59
## num_tl_120dpd_2m 153690 6.80
## num_tl_30dpd 70309 3.11
## num_tl_90g_dpd_24m 70309 3.11
## num_tl_op_past_12m 70309 3.11
## pct_tl_nvr_dlq 70464 3.12
## percent_bc_gt_75 75412 3.34
## pub_rec_bankruptcies 1398 0.06
## tax_liens 138 0.01
## tot_hi_cred_lim 70309 3.11
## total_bal_ex_mort 50063 2.21
## total_bc_limit 50063 2.21
## total_il_high_credit_limit 70309 3.11
## revol_bal_joint 2152681 95.22
## sec_app_fico_range_low 2152680 95.22
## sec_app_fico_range_high 2152680 95.22
## sec_app_inq_last_6mths 2152680 95.22
## sec_app_mort_acc 2152680 95.22
## sec_app_open_acc 2152680 95.22
## sec_app_revol_util 2154517 95.30
## sec_app_open_act_il 2152680 95.22
## sec_app_num_rev_accts 2152680 95.22
## sec_app_chargeoff_within_12_mths 2152680 95.22
## sec_app_collections_12_mths_ex_med 2152680 95.22
## sec_app_mths_since_last_major_derog 2224759 98.41
## deferral_term 2249784 99.52
## hardship_amount 2249784 99.52
## hardship_length 2249784 99.52
## hardship_dpd 2249784 99.52
## orig_projected_additional_accrued_interest 2252050 99.62
## hardship_payoff_balance_amount 2249784 99.52
## hardship_last_payment_amount 2249784 99.52
## settlement_amount 2226455 98.49
## settlement_percentage 2226455 98.49
## settlement_term 2226455 98.49
Comprobamos los nombres de las variables a las que nos enfrentamos, y además calculamos el porcentaje y número de valores perdidos en cada una de esas variables. Hay varias variables que contienen un gran número de valores perdidos, los cuales filtraremos en pasos subsiguientes.
1.2. Filtrado de columnas con muchos datos faltantes.
Eliminamos las columnas que tienen más del 50% de datos faltantes.
threshold <- 0.5 * nrow(data)
columns_before <- ncol(data)
column_names_before <- colnames(data)
data <- data[, colSums(is.na(data)) <= threshold]
columns_after <- ncol(data)
column_names_after <- colnames(data)
eliminated_columns <- setdiff(column_names_before, column_names_after)
cat("Eliminadas", columns_before - columns_after, "columnas con más de un 50% de valores perdidos.\n")
## Eliminadas 30 columnas con más de un 50% de valores perdidos.
cat("Columnas eliminadas:\n", paste(eliminated_columns, collapse = ", "), "\n")
## Columnas eliminadas:
## member_id, mths_since_last_delinq, mths_since_last_record, mths_since_last_major_derog, annual_inc_joint, dti_joint, mths_since_recent_bc_dlq, mths_since_recent_revol_delinq, revol_bal_joint, sec_app_fico_range_low, sec_app_fico_range_high, sec_app_inq_last_6mths, sec_app_mort_acc, sec_app_open_acc, sec_app_revol_util, sec_app_open_act_il, sec_app_num_rev_accts, sec_app_chargeoff_within_12_mths, sec_app_collections_12_mths_ex_med, sec_app_mths_since_last_major_derog, deferral_term, hardship_amount, hardship_length, hardship_dpd, orig_projected_additional_accrued_interest, hardship_payoff_balance_amount, hardship_last_payment_amount, settlement_amount, settlement_percentage, settlement_term
Como vimos en el paso anterior, había variables con muchos valores perdidos, de modo que hemos decidido filtrar las variables que tengan en concreto más del 50% de valores faltantes, que son 30. Vemos las variables filtradas, para no eliminar alguna que resultara de interés a pesar de que la información recopilada de ellas fuera muy poca.
member_id: Un identificador único para cada prestatario en el conjunto de datos. Es una referencia al prestatario dentro del sistema de Lending Club.
mths_since_last_delinq: Número de meses desde la última morosidad (delinquency). Indica cuánto tiempo ha pasado desde que el prestatario no pagó una deuda a tiempo.
mths_since_last_record: Número de meses desde el último registro público (como una bancarrota o una demanda judicial). Si está en blanco, el prestatario no tiene registros públicos recientes.
mths_since_last_major_derog: Número de meses desde la última falta importante en el crédito (derogatory mark), como un cobro grave o una morosidad severa.
annual_inc_joint: Ingreso anual combinado si hay un co-solicitante en el préstamo (como un cónyuge o pareja).
dti_joint: Relación deuda-ingresos (DTI) combinada, que es el porcentaje de los ingresos combinados del solicitante y el co-solicitante destinado a pagar deudas.
mths_since_recent_bc_dlq: Número de meses desde la última morosidad en una línea de crédito rotativo (como una tarjeta de crédito).
mths_since_recent_revol_delinq: Número de meses desde la última morosidad en una cuenta de crédito revolvente (deuda que se puede volver a utilizar después de pagar, como tarjetas de crédito).
revol_bal_joint: Saldo revolvente combinado del solicitante y co-solicitante.
sec_app_fico_range_low: Puntuación FICO mínima del co-solicitante.
sec_app_fico_range_high: Puntuación FICO máxima del co-solicitante.
sec_app_inq_last_6mths: Número de consultas crediticias (hard inquiries) realizadas en los últimos 6 meses para el co-solicitante.
sec_app_mort_acc: Número de cuentas hipotecarias abiertas asociadas al co-solicitante.
sec_app_open_acc: Número total de cuentas abiertas del co-solicitante.
sec_app_revol_util: Utilización de crédito revolvente del co-solicitante (porcentaje de crédito utilizado del total disponible).
sec_app_open_act_il: Número de cuentas activas de crédito a plazos abiertas del co-solicitante.
sec_app_num_rev_accts: Número de cuentas de crédito revolvente del co-solicitante.
sec_app_chargeoff_within_12_mths: Número de cuentas cargadas como pérdida (charge-offs) en los últimos 12 meses para el co-solicitante.
sec_app_collections_12_mths_ex_med: Número de cuentas en colecciones (excluyendo cuentas médicas) del co-solicitante en los últimos 12 meses.
sec_app_mths_since_last_major_derog: Número de meses desde la última falta importante en el crédito del co-solicitante.
deferral_term: Número de meses en los que el pago del préstamo se ha diferido (aplazado).
hardship_amount: Cantidad mensual de pago reducida durante un período de dificultad financiera (hardship).
hardship_length: Duración del período de dificultad financiera (en meses).
hardship_dpd: Número de días en mora (days past due) durante un período de dificultad financiera.
orig_projected_additional_accrued_interest: Cantidad original de interés adicional proyectado que se acumulará debido al aplazamiento del pago.
hardship_payoff_balance_amount: Saldo pendiente que debe pagarse al final del período de dificultad financiera.
hardship_last_payment_amount: Última cantidad de pago realizada durante el período de dificultad financiera.
settlement_amount: Monto acordado en un acuerdo de liquidación para pagar menos de lo que se debe originalmente.
settlement_percentage: Porcentaje del saldo original del préstamo que se acordó pagar en el acuerdo de liquidación.
settlement_term: Duración del acuerdo de liquidación en meses.
A pesar de que hay alguna variable que pueda resultar relevante, procederemos a continuar limpiando, analizando y construyendo nuestro modelo sin ellas. En caso de no ser capaces de llegar a una precisión alta en el modelo construído, podremos acudir a rescatar algunas de ellas. Quizás recopilar información acerca de estas variables sea más complejo o no es viable en muchos casos y es por ello que optamos por seguir, en principio, sin ellas.
1.3. Eliminación de variables con poca variabilidad.
Eliminamos las variables que tienen escasa variabilidad.
num_cores <- detectCores() - 1
check_nzv <- function(col) {
nzv_result <- nearZeroVar(data.frame(col), saveMetrics = TRUE)
return(nzv_result$nzv)
}
columns_before <- ncol(data)
nzv_results <- unlist(mclapply(data, check_nzv, mc.cores = num_cores))
removed_columns <- names(data)[nzv_results] # Nombres de columnas eliminadas
data <- data[, !nzv_results]
columns_after <- ncol(data)
cat("Removed", columns_before - columns_after, "columns with near-zero variance.\n")
## Removed 36 columns with near-zero variance.
cat("Columns removed:", paste(removed_columns, collapse = ", "), "\n")
## Columns removed: pymnt_plan, desc, revol_bal, total_rec_late_fee, recoveries, collection_recovery_fee, collections_12_mths_ex_med, policy_code, verification_status_joint, acc_now_delinq, tot_coll_amt, total_bal_il, max_bal_bc, chargeoff_within_12_mths, delinq_amnt, num_tl_120dpd_2m, num_tl_30dpd, num_tl_90g_dpd_24m, pct_tl_nvr_dlq, tax_liens, total_bal_ex_mort, total_il_high_credit_limit, sec_app_earliest_cr_line, hardship_flag, hardship_type, hardship_reason, hardship_status, hardship_start_date, hardship_end_date, payment_plan_start_date, hardship_loan_status, disbursement_method, debt_settlement_flag, debt_settlement_flag_date, settlement_status, settlement_date
Hacemos uso de la función nearZeroVar para este filtrado de variables con escasa variabilidad y que por tanto no nos aportarán información relevante para el estudio que llevaremos a cabo. Con este filtrado eliminamos 36 variables más, quedando aún 85. En este caso optamos por llevar a cabo una paralelización del proceso, acelerando el cálculo e implementando el uso de memoria. Las variables eliminadas son:
pymnt_plan: Indica si el prestatario está en un plan de pago especial (valor típico: n para no, y para sí).
desc: Descripción del propósito del préstamo escrita por el prestatario (puede contener texto libre).
revol_bal: Saldo total en cuentas de crédito revolvente (como tarjetas de crédito).
total_rec_late_fee: Total de cargos por pagos atrasados recibidos en el préstamo.
recoveries: Monto recuperado después de un cobro fallido o carga como pérdida (charge-off)
collection_recovery_fee: Tarifa asociada con la recuperación de fondos de cobros fallidos.
collections_12_mths_ex_med: Número de cuentas en colecciones (excluyendo cuentas médicas) en los últimos 12 meses.
policy_code: Código interno que describe la política de suscripción del préstamo. Los valores típicos son 1 (préstamos estándar) o 2 (préstamos personalizados).
verification_status_joint: Estado de verificación de ingresos para prestatarios conjuntos.
acc_now_delinq: Número de cuentas actualmente en mora del prestatario.
tot_coll_amt: Monto total de deudas en colecciones para el prestatario.
total_bal_il: Saldo total de cuentas de crédito a plazos (como préstamos personales o automotrices).
max_bal_bc: Saldo máximo registrado en cuentas de crédito revolvente.
chargeoff_within_12_mths: Número de cuentas cargadas como pérdida en los últimos 12 meses.
delinq_amnt: Monto total de morosidad en todas las cuentas del prestatario.
num_tl_120dpd_2m: Número de cuentas que han estado 120 días en mora en los últimos dos meses.
num_tl_30dpd: Número de cuentas con morosidad de 30 días en el historial crediticio.
num_tl_90g_dpd_24m: Número de cuentas con morosidad de 90 días o más en los últimos 24 meses.
pct_tl_nvr_dlq: Porcentaje de cuentas del prestatario que nunca han estado en mora.
tax_liens: Número de embargos fiscales registrados contra el prestatario.
total_bal_ex_mort: Saldo total en todas las cuentas del prestatario, excluyendo hipotecas.
total_il_high_credit_limit: Límite de crédito más alto en cuentas a plazos.
sec_app_earliest_cr_line: Fecha de apertura de la cuenta más antigua del co-solicitante.
hardship_flag: Indica si el prestatario está enfrentando dificultades financieras (Y para sí, N para no).
hardship_type: Tipo de dificultad financiera (por ejemplo, desempleo, reducción de ingresos).
hardship_reason: Razón específica para la dificultad financiera (por ejemplo, "pérdida de empleo").
hardship_status: Estado del proceso de dificultad financiera (aprobado, pendiente, etc.).
hardship_start_date: Fecha de inicio del período de dificultad financiera.
hardship_end_date: Fecha de finalización del período de dificultad financiera.
payment_plan_start_date: Fecha de inicio de un plan de pagos asociado con una dificultad financiera.
hardship_loan_status: Estado del préstamo durante el período de dificultad financiera.
disbursement_method: Método de desembolso del préstamo (por ejemplo, "DirectPay").
debt_settlement_flag: Indica si el prestatario ha entrado en un acuerdo de liquidación de deuda (Y para sí, N para no).
debt_settlement_flag_date: Fecha en la que se marcó el préstamo como sujeto a liquidación de deuda.
settlement_status: Estado del acuerdo de liquidación (por ejemplo, completado, pendiente).
settlement_date: Fecha en la que se completó el acuerdo de liquidación.
1.4. Visualización de la distribución de datos con Principal Component Analysis (PCA).
Llevamos a cabo un análsis de componentes principales para ver la tendencia de agrupación de las muestras.
num_cores <- detectCores() - 1
cl <- makeCluster(num_cores)
registerDoParallel(cl)
numeric_data <- data[sapply(data, is.numeric)]
imputed_data <- foreach(i = 1:ncol(numeric_data), .combine = cbind) %dopar% {
col <- numeric_data[[i]]
ifelse(is.na(col), mean(col, na.rm = TRUE), col)
}
imputed_data <- as.data.frame(imputed_data)
colnames(imputed_data) <- colnames(numeric_data)
pca_result <- prcomp(imputed_data, scale. = TRUE)
pca_data <- data.frame(
PC1 = pca_result$x[, 1],
PC2 = pca_result$x[, 2],
loan_status = data$loan_status
)
ggplot(pca_data, aes(x = PC1, y = PC2, color = loan_status)) +
geom_point(size = 2) +
labs(
title = "PCA",
x = "Componente Principal 1",
y = "Componente Principal 2"
) +
theme_minimal() +
theme(
legend.position = "bottom",
legend.text = element_text(size = 5),
legend.title = element_text(size = 6)
)
stopCluster(cl)
Consecuencia del gran número de muestras presentes en el set de datos, se hace muy difícil obtener resultados de agrupación relevantes al respecto de este PCA.
2.1. Distribución de las variables numéricas.
Visualizamos la distribución de algunas variables numéricas seleccionadas para tener una idea de la dispersión de los datos.
numeric_vars <- names(data)[sapply(data, is.numeric)]
for (var in numeric_vars[1:10]) {
print(ggplot(data, aes_string(x = var)) +
geom_histogram(fill = "blue", color = "black", bins = 30) +
labs(title = paste("Distribución de", var), x = var, y = "Frecuencia"))
}
Con estos plots, vamos viendo la tendencia o dispersión de estas variables numéricas. Si bien no podemos extraer conclusiones relevantes aún, convenía ver de forma visual a qué datos nos enfrentamos y cómo se distrubuyen.
2.2. Análisis de variables categóricas.
Visualizamos la distribución de algunas variables categóricas.
data <- data %>%
mutate(across(where(is.character), as.factor))
categorical_vars <- names(data)[sapply(data, is.factor)]
for (var in categorical_vars[1:10]) {
if (length(levels(data[[var]])) > 10) {
top_levels <- names(sort(table(data[[var]]), decreasing = TRUE)[1:10])
data[[paste0(var, "_top10")]] <- factor(ifelse(data[[var]] %in% top_levels, as.character(data[[var]]), "Other"))
var <- paste0(var, "_top10")
}
p <- ggplot(data, aes_string(x = var)) +
geom_bar(fill = "orange", color = "black") +
labs(title = paste("Distribución de", var), x = var, y = "Frecuencia") +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(p)
}
Con todos estos plots ya nos vamos haciendo una gran idea de cómo se distribuyen las distintas variables numéricas y categóricas, y del tipo de datos e información de la que disponemos. Al igual que se comentó antes acerca de las variables numéricas, no podemos extraer conclusiones relevantes acerca de estos plots, si bien, hemos detectado la variable categórica que será nuestro "target", es decir, loan_status. Con esta variable sabemos si un cliente ha llevado a cabo el pago, el plazo en el que lo ha hecho o si por el contrario, no cumplió con él.
3.1. Análisis de correlación entre variables numéricas.
Calculamos la matriz de correlación y visualizamos un mapa de calor para identificar relaciones entre variables.
cor_matrix <- cor(data[, sapply(data, is.numeric)], use = "pairwise.complete.obs")
high_cor <- findCorrelation(cor_matrix, cutoff = 0.7)
cor_matrix_high <- cor_matrix[high_cor, high_cor]
corrplot(cor_matrix_high, method = "color", type = "upper",
tl.col = "black", tl.srt = 45, tl.cex = 0.55,
col = colorRampPalette(c("red", "white", "blue"))(200),
title = "High Correlation Matrix Heatmap", mar = c(0, 0, 1, 0))
Las variables relacionadas con el monto y los pagos del préstamo (loan_amnt, funded_amnt, total_pymnt) tienen correlaciones altas entre sí, lo que refleja su relación directa en el ciclo del préstamo.
Variables relacionadas con la utilización de crédito (revol_util, bc_util) están correlacionadas entre sí y negativamente con el puntaje FICO (fico_range_high), indicando que prestatarios con mayor solvencia financiera tienden a utilizar menos crédito.
out_prncp (capital pendiente) está inversamente relacionado con los pagos totales (total_pymnt) y está más relacionado con el progreso del préstamo que con las características del prestatario.
De forma más específica, podemos ver lo siguiente:
loan_amnt (Monto del préstamo):
Alta correlación positiva con funded_amnt y funded_amnt_inv. Esto es lógico porque estos valores están directamente relacionados con el monto solicitado y financiado. Correlación moderada con total_pymnt y total_pymnt_inv, lo que sugiere que préstamos más altos tienden a generar pagos totales más grandes.
total_pymnt (Total pagado por el prestatario):
Muy alta correlación con total_pymnt_inv, ya que ambas variables representan el mismo concepto (pagos totales realizados) pero desde perspectivas ligeramente diferentes. Correlación moderada con loan_amnt y funded_amnt, lo que refuerza que préstamos más grandes tienden a requerir mayores pagos.
fico_range_high (Rango alto de FICO):
Correlación negativa moderada con revol_util (utilización del crédito revolvente). Los prestatarios con puntajes FICO más altos suelen tener una menor utilización de crédito. Ligera correlación positiva con tot_hi_cred_lim, ya que los prestatarios con mejores puntajes FICO tienden a tener mayores límites de crédito.
revol_util (Utilización del crédito revolvente):
Correlación positiva con bc_util (utilización de tarjetas de crédito) y tot_cur_bal (saldo total actual), lo que refleja que estas variables están relacionadas con la carga de deuda actual del prestatario. Ligera correlación negativa con variables como fico_range_high, indicando que prestatarios más solventes tienden a usar menos crédito.
out_prncp (Saldo pendiente de capital):
Correlación negativa alta con total_pymnt, ya que a medida que el prestatario paga más, el saldo pendiente de capital disminuye. Correlación moderada con last_fico_range_high, sugiriendo que prestatarios con mejor historial pueden reducir más rápido su saldo.
3.2. Relación entre la variable objetivo y otras variables.
Creamos visualizaciones para explorar la relación entre la variable objetivo y otras variables.
important_vars <- c("last_fico_range_high", "last_fico_range_low", "last_pymnt_amnt",
"total_rec_prncp", "out_prncp", "total_pymnt", "funded_amnt",
"loan_amnt", "installment", "int_rate")
for (var in important_vars) {
p <- ggplot(data, aes(x = factor(loan_status), y = .data[[var]])) +
geom_boxplot(fill = "lightblue") +
labs(title = paste("Distribución de", var, "según el Estado del Préstamo"),
x = "Estado del Préstamo",
y = var) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(p)
}
Estos plots son muy importantes, ya que vemos como hay determinadas variables que cambian o se adaptan de forma muy interesante con respecto a la variable "target". Estados como Fully Paid muestran distribuciones esperadas, con altos valores tanto en pagos totales como en recuperación de principal por ejemplo, destacando que el préstamo fue exitoso. Estados de incumplimiento (Charged Off, Default) y demora (Late) tienen valores bajos en ambas métricas, lo que refleja menores pagos realizados y recuperación limitada del principal. El estado Current tiene una variabilidad alta en estas dos métricas comparadas, mostrando que algunos prestatarios están cerca de completar sus pagos, mientras que otros están más rezagados.
Transformamos la columna loan_status en una variable objetivo target con cinco categorías. Las muestras que se hallan en un estado diferente a esas cinco categorías etiquetadas, las eliminamos. Nos quedamos en este punto con 1,379,602 muestras.
data <- data %>%
mutate(target = case_when(
loan_status == "Fully Paid" ~ 0,
loan_status == "In Grace Period" ~ 1,
loan_status == "Late (16-30 days)" ~ 2,
loan_status == "Late (31-120 days)" ~ 3,
loan_status %in% c("Charged Off", "Default") ~ 4,
TRUE ~ NA_real_
)) %>%
select(-loan_status) %>%
filter(!is.na(target))
Fully Paid (Totalmente Pagado): El préstamo ha sido pagado en su totalidad, lo que significa que el prestatario cumplió con todos los pagos acordados según el contrato del préstamo.
In Grace Period (En Período de Gracia): El prestatario está en un período de gracia, que es un tiempo adicional otorgado para realizar el pago antes de que se considere en mora. Durante este período, el prestatario no incurre en penalizaciones.
Late (16-30 days) (Tarde 16-30 días): El préstamo está en mora, ya que el prestatario no ha realizado el pago correspondiente dentro del plazo. Este estado indica que el pago se ha retrasado entre 16 y 30 días.
Late (31-120 days) (Tarde 31-120 días): El préstamo continúa en mora, pero el retraso es más significativo, entre 31 y 120 días. Este estado puede afectar negativamente la calificación crediticia del prestatario.
Charged Off (Cobrada como Pérdida) / Default (Incumplimiento): Este estado indica que el prestamista ha determinado que el préstamo es incobrable y lo ha dado de baja como pérdida (charged off) después de múltiples intentos de cobranza. Esto puede ocurrir después de un período prolongado de impago, generalmente de 120 días o más.
4.1. Clustering llevado a cabo con los datos filtrados y preprocesados hasta el momento.
variables_numericas <- data %>%
select_if(is.numeric) %>%
select(-target)
datos_normalizados <- scale(variables_numericas)
filas_completas <- complete.cases(datos_normalizados)
datos_normalizados <- datos_normalizados[filas_completas, ]
target_filtrado <- data$target[filas_completas]
data_muestreo <- data.frame(datos_normalizados, target = target_filtrado)
muestras_por_clase <- 200
data_muestreada <- data_muestreo %>%
group_by(target) %>%
sample_n(muestras_por_clase)
datos_normalizados_muestreado <- data_muestreada %>%
select(-target)
## Adding missing grouping variables: `target`
target_filtrado_muestreado <- data_muestreada$target
nrow(datos_normalizados_muestreado)
## [1] 1000
length(target_filtrado_muestreado)
## [1] 1000
num_clusters <- 5
n_iterations <- 25
kmeans_result <- list()
for (i in 1:n_iterations) {
kmeans_result[[i]] <- kmeans(datos_normalizados_muestreado, centers = num_clusters, nstart = 1)
}
best_kmeans <- kmeans_result[[which.min(sapply(kmeans_result, function(x) x$tot.withinss))]]
pca_result <- prcomp(datos_normalizados_muestreado)
resultados <- data.frame(
PC1 = pca_result$x[,1],
PC2 = pca_result$x[,2],
Cluster = as.factor(best_kmeans$cluster),
Target = as.factor(target_filtrado_muestreado)
)
plot <- ggplot(resultados, aes(x = PC1, y = PC2, color = Target, shape = Cluster)) +
geom_point(size = 3, alpha = 0.7) +
theme_minimal() +
labs(title = "Clustering K-means coloreado por Target",
x = "Primera Componente Principal",
y = "Segunda Componente Principal") +
scale_color_discrete(name = "Target") +
scale_shape_discrete(name = "Cluster")
print(plot)
tabla_comparacion <- table(best_kmeans$cluster, target_filtrado_muestreado)
print(tabla_comparacion)
## target_filtrado_muestreado
## 0 1 2 3 4
## 1 65 9 6 3 22
## 2 99 57 66 53 103
## 3 36 19 25 28 75
## 4 0 80 72 71 0
## 5 0 35 31 45 0
prop_tabla <- prop.table(tabla_comparacion, margin = 1)
print(prop_tabla)
## target_filtrado_muestreado
## 0 1 2 3 4
## 1 0.61904762 0.08571429 0.05714286 0.02857143 0.20952381
## 2 0.26190476 0.15079365 0.17460317 0.14021164 0.27248677
## 3 0.19672131 0.10382514 0.13661202 0.15300546 0.40983607
## 4 0.00000000 0.35874439 0.32286996 0.31838565 0.00000000
## 5 0.00000000 0.31531532 0.27927928 0.40540541 0.00000000
Importante: Los clusters aparecen enumerado del 1 al 5 y nuestras categorías del 0 al 4.
Como vemos en este clustering (subset de 200 muestras por clase), y en las tablas de resultados, fundamentalmente se clasifican bien las categorías más extremas, es decir, los "Fully paid" (0) o los clientes "Charged Off" o "Default" (4), mientras en los restantes (pagos tardíos) parece que hay bastante confusión. A pesar de ello, que el 86% de las muestras de la categoría "Fully paid" clasifiquen en un mismo cluster parece un dato bastante bueno, y que demuestra que las variables aisladas empiezan a aportar información clave de cara al cumplimiento de nuestro objetivo clave, es decir, la elaboración de un modelo que distinga las 5 categorías propuestas de pago/impago de préstamos.
Visualizamos la distribución de la variable objetivo.
pie_data <- data %>%
group_by(target) %>%
summarise(count = n()) %>%
mutate(label = c("Fully Paid", "In Grace Period", "Late (16-30 days)",
"Late (31-120 days)", "Charged Off / Default")[target + 1]) %>%
mutate(percentage = count / sum(count) * 100,
label_text = paste0(label, " (", round(percentage, 1), "%)"))
custom_colors <- c("#1f77b4", "#ff7f0e", "#2ca02c", "#d62728", "#9467bd")
p <- plot_ly(pie_data, labels = ~label, values = ~count, type = 'pie',
textposition = 'inside',
textinfo = 'label+percent',
insidetextfont = list(color = '#FFFFFF'),
hoverinfo = 'text',
text = ~paste(label, "<br>", count, "préstamos"),
marker = list(colors = custom_colors,
line = list(color = '#FFFFFF', width = 1)),
showlegend = FALSE) %>%
layout(title = "Distribución de la Variable Objetivo",
xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))
p
Se observa como hay un elevadísimo porcentaje (78%) de préstamos pagados, y también un porcentaje importante (del 19,5% después del último filtrado de muestras), de préstamos no pagados.
Entrenamos un modelo Random Forest (autoexplicativo) para evaluar la importancia de las características. De este modo seleccionaremos las variables clave para la red neuronal que posteriormente diseñaremos.
num_cores <- detectCores() - 1
num_cores
## [1] 7
cl <- makeCluster(num_cores)
registerDoParallel(cl)
response_var <- "target"
features <- setdiff(colnames(data), response_var)
data_subset <- na.omit(data[, c(features, response_var)])
reduce_categories <- function(x, top_n = 50) {
if (is.factor(x) && nlevels(x) > 53) {
top_levels <- names(sort(table(x), decreasing = TRUE)[1:top_n])
return(factor(ifelse(x %in% top_levels, as.character(x), "Other")))
}
return(x)
}
data_subset <- data_subset %>% mutate(across(where(is.factor), ~reduce_categories(.)))
factor_cols <- sapply(data_subset, is.factor)
sapply(data_subset[, factor_cols], nlevels)
## id term grade sub_grade
## 51 3 8 36
## emp_title emp_length home_ownership verification_status
## 51 12 7 4
## issue_d url purpose title
## 37 51 15 14
## zip_code addr_state earliest_cr_line initial_list_status
## 51 52 51 3
## last_pymnt_d next_pymnt_d last_credit_pull_d application_type
## 41 5 42 3
## id_top10 sub_grade_top10 emp_title_top10 emp_length_top10
## 11 11 11 11
## issue_d_top10
## 11
rf_model <- foreach(ntree = rep(floor(500/num_cores), num_cores),
.combine = randomForest::combine,
.packages = "randomForest") %dopar% {
randomForest(as.factor(target) ~ .,
data = data_subset,
ntree = ntree,
importance = TRUE)
}
stopCluster(cl)
Para ejecutar el proceso de forma eficiente, generamos un subset de los datos sin NAs, y además paralelizamos el proceso.
print(rf_model)
##
## Call:
## randomForest(formula = as.factor(target) ~ ., data = data_subset, ntree = ntree, importance = TRUE)
## Type of random forest: classification
## Number of trees: 497
## No. of variables tried at each split: 9
importance_scores <- importance(rf_model)
sorted_importance <- sort(importance_scores[, "MeanDecreaseGini"], decreasing = TRUE)
varImpPlot(rf_model, main = "Variable Importance", cex = 0.6)
importance_df <- data.frame(
variable = names(sorted_importance[1:30]),
importance = sorted_importance[1:30]
)
ggplot(importance_df, aes(x = reorder(variable, importance), y = importance)) +
geom_bar(stat = "identity", fill = "skyblue") +
coord_flip() + # Flip coordinates to make horizontal bars
theme_minimal() +
labs(
title = "Top 30 Most Important Variables",
x = "Variables",
y = "Importance"
) +
theme(
axis.text.y = element_text(size = 8), # Adjust text size for y-axis labels
plot.margin = unit(c(1, 1, 1, 1), "cm") # Add margins using unit()
)
sorted_importance[1:30]
## last_fico_range_low last_fico_range_high last_pymnt_amnt
## 29393.2570 28774.1436 24524.5504
## total_rec_prncp next_pymnt_d out_prncp_inv
## 22396.6415 9491.3941 8428.7120
## total_pymnt_inv out_prncp total_pymnt
## 8096.4022 7964.2958 7733.9846
## last_pymnt_d funded_amnt funded_amnt_inv
## 5015.5107 4719.9391 4224.1246
## loan_amnt installment total_rec_int
## 4183.0644 3658.3711 2079.9042
## int_rate last_credit_pull_d grade
## 1143.4162 1043.4005 1009.3591
## issue_d sub_grade term
## 901.8886 806.3430 687.2349
## addr_state sub_grade_top10 emp_length
## 687.2233 382.9835 336.4421
## emp_length_top10 earliest_cr_line zip_code
## 320.7056 314.7854 296.5549
## dti fico_range_high fico_range_low
## 294.6912 294.1019 291.9964
#saveRDS(rf_model, file = "rf_model.rds")
# loaded_model <- readRDS("rf_model.rds")
Observamos qué variables tienen más importancia en la predicción del estado en el que se encuentra el préstamo y aislamos entre las 30 más relevantes, las que tomemos para entrenar el modelo en cuestión.
Finalmente, filtramos con las variables seleccionadas anteriormente, y normalizamos y escalamos los datos:
top_30_vars <- names(sorted_importance[1:30])
numeric_vars <- sapply(data[, top_30_vars], is.numeric)
print(numeric_vars)
## last_fico_range_low last_fico_range_high last_pymnt_amnt
## TRUE TRUE TRUE
## total_rec_prncp next_pymnt_d out_prncp_inv
## TRUE FALSE TRUE
## total_pymnt_inv out_prncp total_pymnt
## TRUE TRUE TRUE
## last_pymnt_d funded_amnt funded_amnt_inv
## FALSE TRUE TRUE
## loan_amnt installment total_rec_int
## TRUE TRUE TRUE
## int_rate last_credit_pull_d grade
## TRUE FALSE FALSE
## issue_d sub_grade term
## FALSE FALSE FALSE
## addr_state sub_grade_top10 emp_length
## FALSE FALSE FALSE
## emp_length_top10 earliest_cr_line zip_code
## FALSE FALSE FALSE
## dti fico_range_high fico_range_low
## TRUE TRUE TRUE
numeric_var_names <- names(numeric_vars[numeric_vars])
print("Numeric variables:")
## [1] "Numeric variables:"
print(numeric_var_names)
## [1] "last_fico_range_low" "last_fico_range_high" "last_pymnt_amnt"
## [4] "total_rec_prncp" "out_prncp_inv" "total_pymnt_inv"
## [7] "out_prncp" "total_pymnt" "funded_amnt"
## [10] "funded_amnt_inv" "loan_amnt" "installment"
## [13] "total_rec_int" "int_rate" "dti"
## [16] "fico_range_high" "fico_range_low"
selected_vars <- c(numeric_var_names, "grade", "emp_length")
data_filtered <- data[, c(selected_vars, "target")]
data_filtered <- cbind(data_filtered, model.matrix(~ grade + emp_length - 1, data = data_filtered))
new_columns <- colnames(data_filtered)[grepl("grade|emp_length", colnames(data_filtered))]
selected_vars <- c(numeric_var_names, new_columns)
preprocess_params <- preProcess(data_filtered[, selected_vars], method = c("center", "scale"))
data_normalized <- predict(preprocess_params, data_filtered[, selected_vars])
data_final <- cbind(data_normalized, target = data_filtered$target)
data_final$target <- as.factor(data_final$target)
print(dim(data_final))
## [1] 1379602 39
print(names(data_final))
## [1] "last_fico_range_low" "last_fico_range_high" "last_pymnt_amnt"
## [4] "total_rec_prncp" "out_prncp_inv" "total_pymnt_inv"
## [7] "out_prncp" "total_pymnt" "funded_amnt"
## [10] "funded_amnt_inv" "loan_amnt" "installment"
## [13] "total_rec_int" "int_rate" "dti"
## [16] "fico_range_high" "fico_range_low" "grade"
## [19] "emp_length" "grade.1" "gradeA"
## [22] "gradeB" "gradeC" "gradeD"
## [25] "gradeE" "gradeF" "gradeG"
## [28] "emp_length< 1 year" "emp_length1 year" "emp_length10+ years"
## [31] "emp_length2 years" "emp_length3 years" "emp_length4 years"
## [34] "emp_length5 years" "emp_length6 years" "emp_length7 years"
## [37] "emp_length8 years" "emp_length9 years" "target"
write.csv(data_final, file = "data_credit_risk_neural_network_rmd.csv", row.names = FALSE)
Ya tenemos una matriz de datos preparada y guardada para entrenar nuestro modelo de red neuronal.
Entrenamos un modelo de agrupamiento utilizando el algoritmo KNN (K-Nearest Neighbors) sobre los datos previamente filtrados, escalados y normalizados. Este proceso nos permitirá evaluar la capacidad del modelo para clasificar las muestras en sus respectivos grupos, midiendo así la precisión y efectividad del algoritmo en la identificación de patrones y relaciones dentro de los datos.
data_final <- read.csv("data_credit_risk_neural_network_rmd.csv")
variables_numericas <- data_final %>%
dplyr::select_if(is.numeric) %>%
dplyr::select(-target)
datos_normalizados <- variables_numericas
filas_completas <- complete.cases(datos_normalizados)
datos_normalizados <- datos_normalizados[filas_completas, ]
target_filtrado <- data_final$target[filas_completas]
set.seed(123)
indices <- createDataPartition(target_filtrado, p = 0.8, list = FALSE)
datos_train <- datos_normalizados[indices, ]
datos_test <- datos_normalizados[-indices, ]
target_train <- target_filtrado[indices]
target_test <- target_filtrado[-indices]
num_cores <- parallel::detectCores() - 1
cl <- makeCluster(num_cores)
registerDoParallel(cl)
k_values <- c(3, 5, 7)
knn_results <- foreach(k = k_values, .combine = rbind, .packages = "class") %dopar% {
knn_pred <- knn(train = datos_train, test = datos_test, cl = target_train, k = k)
conf_matrix <- table(Predicted = knn_pred, Actual = target_test)
accuracy <- sum(diag(conf_matrix)) / sum(conf_matrix)
data.frame(k = k, Accuracy = accuracy)
}
print(knn_results)
## k Accuracy
## 1 3 0.9689963
## 2 5 0.9694168
## 3 7 0.9693443
save(datos_train, target_train, file = "knn_model_data.RData")
pca_test <- prcomp(datos_test)
pca_test_df <- data.frame(PC1 = pca_test$x[, 1], PC2 = pca_test$x[, 2])
k <- 5
knn_pred <- knn(train = datos_train, test = datos_test, cl = target_train, k = k)
pca_test_df$True_Label <- as.factor(target_test)
pca_test_df$Predicted_Label <- as.factor(knn_pred)
plot <- ggplot(pca_test_df, aes(x = PC1, y = PC2)) +
geom_point(aes(color = True_Label, shape = Predicted_Label), size = 3, alpha = 0.7) +
theme_minimal() +
labs(
title = "Clustering of Test Data (KNN Predictions)",
x = "First Principal Component",
y = "Second Principal Component"
) +
scale_color_discrete(name = "True Label") +
scale_shape_discrete(name = "Predicted Label")
print(plot)
umap_config <- umap.defaults
umap_config$n_neighbors <- 15
umap_config$min_dist <- 0.1
umap_config$metric <- "euclidean"
datos_test_matrix <- as.matrix(datos_test)
umap_test <- umap(
X = datos_test_matrix,
n_neighbors = 15,
min_dist = 0.1,
metric = "euclidean",
n_components = 3,
n_threads = parallel::detectCores() - 1
)
umap_test_df <- data.frame(
UMAP1 = umap_test[, 1],
UMAP2 = umap_test[, 2],
UMAP3 = umap_test[, 3],
True_Label = as.factor(target_test)
)
k <- 5
knn_pred <- knn(train = datos_train, test = datos_test, cl = target_train, k = k)
umap_test_df$Predicted_Label <- as.factor(knn_pred)
set.seed(123)
sampled_data <- umap_test_df %>%
group_by(True_Label) %>%
sample_n(min(50, n())) %>%
ungroup()
plot <- plot_ly(sampled_data,
x = ~UMAP1, y = ~UMAP2, z = ~UMAP3,
color = ~True_Label,
symbol = ~Predicted_Label,
type = 'scatter3d',
mode = 'markers',
marker = list(size = 5, opacity = 0.7)) %>%
layout(
title = "3D UMAP Clustering of Test Data (KNN Predictions)",
scene = list(
xaxis = list(title = "UMAP Dimension 1"),
yaxis = list(title = "UMAP Dimension 2"),
zaxis = list(title = "UMAP Dimension 3")
)
)
#htmlwidgets::saveWidget(
# widget = plot,
# file = "umap_knn_plot.html",
# selfcontained = TRUE
#)
Como podemos observar, la precisión del modelo es muy alta (en torno al 97%). Además hemos representado un plot en 3 dimensiones con UMAP (Uniform Manifold Approximation and Projection), en el que se observa la disposición de los clientes con las etiquetas reales y predichas en este enlace, así como solamente con las etiquetas del cluster al que se predice que pertenecen (ver aquí). Con todo esto, tomamos la matriz normalizada, escalada y limpia, y entrenaremos otro modelo de redes neuronales más complejo, en pro de ver la precisión del mismo y usarlo de forma interactiva en una web montada con R Shiny.